home *** CD-ROM | disk | FTP | other *** search
/ Dr. Windows 3 / dr win3.zip / dr win3 / UTILITY1 / MSWLGO35.ZIP / EXAMPLES / DOCTOR < prev    next >
Text File  |  1993-04-12  |  22KB  |  523 lines

  1. ;
  2. ; Function:
  3. ;
  4. ; Simulated Intelligent Doctor (This is a SAVE of DOCSETUP with "setup" done)
  5. ;
  6. ; To run:
  7. ;
  8. ; Load "doctor
  9. ; Call DOCTOR
  10. ;
  11. TO #GATHER :SEN
  12. IF EMPTYP :SEN [OP :SEN]
  13. IF NOT TRY.PRED [OP :SEN]
  14. MAKE :SPECIAL.VAR LPUT FIRST :SEN THING :SPECIAL.VAR
  15. OP #GATHER BF :SEN
  16. END
  17.  
  18. TO #TEST :SEN
  19. IF MATCH BF :PAT :SEN [OP "TRUE]
  20. IF EMPTYP THING :SPECIAL.VAR [OP "FALSE]
  21. OP #TEST2 FPUT LAST THING :SPECIAL.VAR :SEN
  22. END
  23.  
  24. TO #TEST2 :SEN
  25. MAKE :SPECIAL.VAR BL THING :SPECIAL.VAR
  26. OP #TEST :SEN
  27. END
  28.  
  29. TO &TEST :TF
  30. IF EMPTYP THING :SPECIAL.VAR [OP "FALSE]
  31. OP :TF
  32. END
  33.  
  34. TO @TEST :SEN
  35. IF @TRY.PRED [IF MATCH BF :PAT :SEN [OP "TRUE]]
  36. IF EMPTYP THING :SPECIAL.VAR [OP "FALSE]
  37. OP @TEST2 FPUT LAST THING :SPECIAL.VAR :SEN
  38. END
  39.  
  40. TO @TEST2 :SEN
  41. MAKE :SPECIAL.VAR BL THING :SPECIAL.VAR
  42. OP @TEST :SEN
  43. END
  44.  
  45. TO @TRY.PRED
  46. IF LISTP :SPECIAL.PRED [OP MATCH :SPECIAL.PRED THING :SPECIAL.VAR]
  47. OP RUN LIST :SPECIAL.PRED THING :SPECIAL.VAR
  48. END
  49.  
  50. TO ADDPUNCT :STUFF :CHAR
  51. IF WORDP :STUFF [OUTPUT WORD :STUFF :CHAR]
  52. IF EMPTYP :STUFF [OUTPUT :CHAR]
  53. OUTPUT SE BL :STUFF WORD LAST :STUFF :CHAR
  54. END
  55.  
  56. TO ALWAYS :X
  57. OP "TRUE
  58. END
  59.  
  60. TO ANALYZE :SENTENCE :KEYWORDS
  61. LOCAL [RULES KEYWORD]
  62. IF EMPTYP :KEYWORDS [NORULES STOP]
  63. MAKE "KEYWORD FIRST :KEYWORDS
  64. MAKE "RULES GPROP :KEYWORD "RULES
  65. IF WORDP FIRST :RULES ~
  66.    [MAKE "KEYWORD FIRST :RULES MAKE "RULES GPROP :KEYWORD "RULES]
  67. CHECKRULES :KEYWORD :RULES
  68. END
  69.  
  70. TO ANYOF :SEN
  71. OP ANYOF1 :SEN :IN.LIST
  72. END
  73.  
  74. TO ANYOF1 :SEN :PATS
  75. IF EMPTYP :PATS [OP "FALSE]
  76. IF MATCH FIRST :PATS :SEN [OP "TRUE]
  77. OP ANYOF1 :SEN BF :PATS
  78. END
  79.  
  80. TO BELIEFP :WORD
  81. OUTPUT NOT EMPTYP GPROP :WORD "BELIEF
  82. END
  83.  
  84. TO CHECKPRIORITY :WORD
  85. LOCAL "PRIORITY
  86. MAKE "PRIORITY GPROP :WORD "PRIORITY
  87. IF EMPTYP :PRIORITY [STOP]
  88. IF EMPTYP :KEYWORDS [MAKE "KEYWORDS ( LIST :WORD ) STOP]
  89. IFELSE :PRIORITY > ( GPROP FIRST :KEYWORDS "PRIORITY ) ~
  90.        [MAKE "KEYWORDS FPUT :WORD :KEYWORDS] ~
  91.        [MAKE "KEYWORDS LPUT :WORD :KEYWORDS]
  92. END
  93.  
  94. TO CHECKRULES :KEYWORD :RULES
  95. IF NOT MATCH FIRST :RULES :SENTENCE ~
  96.    [CHECKRULES :KEYWORD BF BF :RULES STOP]
  97. DORULE FIRST BF :RULES
  98. END
  99.  
  100. TO DOCTOR
  101. LOCAL [TEXT SENTENCE STUFF A B C RULES KEYWORDS]
  102. MAKE "MEMORY []
  103. PR [HELLO, I AM THE DOCTOR. WHAT CAN I DO FOR YOU?]
  104. PR [PLEASE END YOUR REMARKS WITH AN EMPTY LINE.]
  105. PR []
  106. LOOP
  107. END
  108.  
  109. TO DORULE :RULE
  110. LOCAL "PRINT
  111. MAKE "PRINT FIRST GPROP :KEYWORD :RULE
  112. PPROP :KEYWORD :RULE LPUT :PRINT BF GPROP :KEYWORD :RULE
  113. IF EQUALP :PRINT "NEWKEY [ANALYZE :SENTENCE BF :KEYWORDS STOP]
  114. IF WORDP :PRINT [CHECKRULES :PRINT GPROP :PRINT "RULES STOP]
  115. IF EQUALP FIRST :PRINT "PRE ~
  116.    [ANALYZE RECONSTRUCT FIRST BF :PRINT BF BF :PRINT STOP]
  117. PRINT RECONSTRUCT :PRINT
  118. MEMORY :KEYWORD :SENTENCE
  119. END
  120.  
  121. TO FAMILYP :WORD
  122. OUTPUT NOT EMPTYP GPROP :WORD "FAMILY
  123. END
  124.  
  125. TO GETSENTENCE :TEXT
  126. MAKE "KEYWORDS []
  127. OUTPUT GETSENTENCE1 :TEXT []
  128. END
  129.  
  130. TO GETSENTENCE1 :TEXT :OUT
  131. IF EMPTYP :TEXT [OUTPUT :OUT]
  132. IF EQUALP FIRST :TEXT ". ~
  133.    [IFELSE EMPTYP :KEYWORDS ~
  134.            [OUTPUT GETSENTENCE1 BF :TEXT []] [OUTPUT :OUT]]
  135. CHECKPRIORITY FIRST :TEXT
  136. OUTPUT GETSENTENCE1 BF :TEXT SE :OUT TRANSLATE FIRST :TEXT
  137. END
  138.  
  139. TO GETSTUFF :STUFF
  140. LOCAL "LINE
  141. MAKE "LINE RL
  142. IF EMPTYP :LINE [OP :STUFF]
  143. OP GETSTUFF SE :STUFF :LINE
  144. END
  145.  
  146. TO IN :WORD
  147. OP MEMBERP :WORD :IN.LIST
  148. END
  149.  
  150. TO LASTRESORT
  151. PRINT FIRST :LASTRESORT
  152. MAKE "LASTRESORT LPUT FIRST :LASTRESORT BF :LASTRESORT
  153. END
  154.  
  155. TO LOOP
  156. MAKE "TEXT TOKENIZE GETSTUFF []
  157. MAKE "SENTENCE GETSENTENCE :TEXT
  158. ANALYZE :SENTENCE :KEYWORDS
  159. PRINT []
  160. LOOP
  161. END
  162.  
  163. TO MATCH :PAT :SEN
  164. LOCAL [SPECIAL.VAR SPECIAL.PRED SPECIAL.BUFFER IN.LIST]
  165. IF OR WORDP :PAT WORDP :SEN [OP "FALSE]
  166. IF EMPTYP :PAT [OP EMPTYP :SEN]
  167. IF LISTP FIRST :PAT [OP SPECIAL FPUT "!: :PAT :SEN]
  168. IF MEMBERP FIRST FIRST :PAT [? # ! & @] [OP SPECIAL :PAT :SEN]
  169. IF EMPTYP :SEN [OP "FALSE]
  170. IF EQUALP FIRST :PAT FIRST :SEN [OP MATCH BF :PAT BF :SEN]
  171. OP "FALSE
  172. END
  173.  
  174. TO MATCH!
  175. IF EMPTYP :SEN [OP "FALSE]
  176. IF NOT TRY.PRED [OP "FALSE]
  177. MAKE :SPECIAL.VAR FIRST :SEN
  178. OP MATCH BF :PAT BF :SEN
  179. END
  180.  
  181. TO MATCH#
  182. MAKE :SPECIAL.VAR []
  183. OP #TEST #GATHER :SEN
  184. END
  185.  
  186. TO MATCH&
  187. OP &TEST MATCH#
  188. END
  189.  
  190. TO MATCH?
  191. MAKE :SPECIAL.VAR []
  192. IF EMPTYP :SEN [OP MATCH BF :PAT :SEN]
  193. IF NOT TRY.PRED [OP MATCH BF :PAT :SEN]
  194. MAKE :SPECIAL.VAR FIRST :SEN
  195. IF MATCH BF :PAT BF :SEN [OP "TRUE]
  196. MAKE :SPECIAL.VAR []
  197. OP MATCH BF :PAT :SEN
  198. END
  199.  
  200. TO MATCH@
  201. MAKE :SPECIAL.VAR :SEN
  202. OP @TEST []
  203. END
  204.  
  205. TO MEMORY :KEYWORD :SENTENCE
  206. LOCAL [RULES RULE NAME]
  207. MAKE "RULES GPROP :KEYWORD "MEMR
  208. IF EMPTYP :RULES [STOP]
  209. IF NOT MATCH FIRST :RULES :SENTENCE [STOP]
  210. MAKE "NAME LAST :RULES
  211. MAKE "RULES GPROP :KEYWORD :NAME
  212. MAKE "RULE FIRST :RULES
  213. PPROP :KEYWORD :NAME LPUT :RULE BF :RULES
  214. MAKE "MEMORY FPUT RECONSTRUCT :SENTENCE :MEMORY
  215. END
  216.  
  217. TO NORULES
  218. IFELSE :MEMFLAG [USEMEMORY] [LASTRESORT]
  219. MAKE "MEMFLAG NOT :MEMFLAG
  220. END
  221.  
  222. TO PARSE.SPECIAL :WORD :VAR
  223. IF EMPTYP :WORD [OP LIST :VAR "ALWAYS]
  224. IF EQUALP FIRST :WORD ": [OP LIST :VAR BF :WORD]
  225. OP PARSE.SPECIAL BF :WORD WORD :VAR FIRST :WORD
  226. END
  227.  
  228. TO QUOTED :THING
  229. IF LISTP :THING [OP :THING]
  230. OP WORD "" :THING
  231. END
  232.  
  233. TO RECONSTRUCT :SENTENCE
  234. IF EMPTYP :SENTENCE [OUTPUT []]
  235. IF NOT EQUALP ": FIRST FIRST :SENTENCE ~
  236.    [OUTPUT FPUT FIRST :SENTENCE RECONSTRUCT BF :SENTENCE]
  237. OUTPUT SE REWORD FIRST :SENTENCE RECONSTRUCT BF :SENTENCE
  238. END
  239.  
  240. TO REWORD :WORD
  241. IF MEMBERP LAST :WORD [. ? ,] [OUTPUT ADDPUNCT REWORD BL :WORD LAST :WORD]
  242. OUTPUT THING BF :WORD
  243. END
  244.  
  245. TO SET.IN
  246. MAKE "IN.LIST FIRST BF :PAT
  247. MAKE "PAT FPUT FIRST :PAT BF BF :PAT
  248. END
  249.  
  250. TO SET.SPECIAL :LIST
  251. MAKE "SPECIAL.VAR FIRST :LIST
  252. MAKE "SPECIAL.PRED LAST :LIST
  253. IF EMPTYP :SPECIAL.VAR [MAKE "SPECIAL.VAR "SPECIAL.BUFFER]
  254. IF MEMBERP :SPECIAL.PRED [IN ANYOF] [SET.IN]
  255. IF NOT EMPTYP :SPECIAL.PRED [STOP]
  256. MAKE "SPECIAL.PRED FIRST BF :PAT
  257. MAKE "PAT FPUT FIRST :PAT BF BF :PAT
  258. END
  259.  
  260. TO SPECIAL :PAT :SEN
  261. SET.SPECIAL PARSE.SPECIAL BF FIRST :PAT "
  262. OP RUN FPUT WORD "MATCH FIRST FIRST :PAT []
  263. END
  264.  
  265. TO TOKENIZE :TEXT
  266. IF EMPTYP :TEXT [OUTPUT []]
  267. OUTPUT SE TOKENWORD FIRST :TEXT " TOKENIZE BF :TEXT
  268. END
  269.  
  270. TO TOKENWORD :WORD :OUT
  271. IF EMPTYP :WORD [OUTPUT :OUT]
  272. IF MEMBERP FIRST :WORD [, " ] [OUTPUT TOKENWORD BF :WORD :OUT]
  273. IF MEMBERP FIRST :WORD [. ? ! |;|] [OUTPUT SE :OUT ".]
  274. OUTPUT TOKENWORD BF :WORD WORD :OUT FIRST :WORD
  275. END
  276.  
  277. TO TRANSLATE :WORD
  278. LOCAL "NEW
  279. MAKE "NEW GPROP :WORD "TRANSLATION
  280. OUTPUT IFELSE EMPTYP :NEW [:WORD] [:NEW]
  281. END
  282.  
  283. TO TRY.PRED
  284. IF LISTP :SPECIAL.PRED [OP MATCH :SPECIAL.PRED FIRST :SEN]
  285. OP RUN LIST :SPECIAL.PRED QUOTED FIRST :SEN
  286. END
  287.  
  288. TO USEMEMORY
  289. IF EMPTYP :MEMORY [LASTRESORT STOP]
  290. PRINT FIRST :MEMORY
  291. MAKE "MEMORY BF :MEMORY
  292. END
  293.  
  294. Make "gensym.number 80
  295. Make "lastresort [[I AM NOT SURE I UNDERSTAND YOU FULLY.] [PLEASE GO ON.] [WHAT DOES THAT SUGGEST TO YOU?] [DO YOU FEEL STRONGLY ABOUT DISCUSSING SUCH THINGS?]]
  296. Make "memflag "FALSE
  297. Pprop "alike "RULES [DIT]
  298. Pprop "alike "PRIORITY 10
  299. Pprop "always "g69 [[CAN YOU THINK OF A SPECIFIC EXAMPLE?] [WHEN?] [WHAT INCIDENT ARE YOU THINKING OF?] [REALLY, ALWAYS?] [WHAT IF THIS NEVER HAPPENED?]]
  300. Pprop "always "RULES [[#] g69]
  301. Pprop "always "PRIORITY 1
  302. Pprop "am "g19 [[WHY DO YOU SAY "AM"?] [I DON'T UNDERSTAND THAT.]]
  303. Pprop "am "g18 [[DO YOU BELIEVE YOU ARE :STUFF?] [WOULD YOU WANT TO BE :STUFF?] [YOU WISH I WOULD TELL YOU YOU ARE :STUFF.] [WHAT WOULD IT MEAN IF YOU WERE :STUFF?] HOW]
  304. Pprop "am "RULES [[# ARE YOU #STUFF] g18 [#] g19]
  305. Pprop "am "TRANSLATION "ARE
  306. Pprop "am "PRIORITY 0
  307. Pprop "are "g24 [[DID YOU THINK THEY MIGHT NOT BE :STUFF?] [WOULD YOU LIKE IT IF THEY WERE NOT :STUFF?] [WHAT IF THEY WERE NOT :STUFF?] [POSSIBLY THEY ARE :STUFF.]]
  308. Pprop "are "g23 [HOW]
  309. Pprop "are "g22 [[WHY ARE YOU INTERESTED IN WHETHER I AM :STUFF OR NOT?] [WOULD YOU PREFER IF I WEREN'T :STUFF?] [PERHAPS I AM :STUFF IN YOUR FANTASIES.] [DO YOU SOMETIMES THINK I AM :STUFF?] HOW]
  310. Pprop "are "g21 [[WHAT MAKES YOU THINK THERE ARE :STUFF?] [DO YOU USUALLY CONSIDER :STUFF?] [DO YOU WISH THERE WERE :STUFF?]]
  311. Pprop "are "g20 [[PRE [:A THERE ARE :B] ARE]]
  312. Pprop "are "RULES [[#A THERE ARE #B YOU #C] g20 [# THERE ARE &STUFF] g21 [# ARE I #STUFF] g22 [ARE #] g23 [# ARE #STUFF] g24]
  313. Pprop "are "PRIORITY 0
  314. Ppro